home *** CD-ROM | disk | FTP | other *** search
/ Aminet 35 / Aminet 35 (2000)(Schatztruhe)[!][Feb 2000].iso / Aminet / gfx / misc / gnuplot-src.lha / gnuplot-3.7.1src / gnuplot-3.7.1.lha / gnuplot-3.7.1 / vms.c < prev    next >
Encoding:
C/C++ Source or Header  |  1998-11-20  |  7.6 KB  |  256 lines
  1. #ifndef lint0ö ø&¨p,*RCSid = "$Id: vms.c,v 1.6 1998/11/20 12:14:51 lhecking Exp $";
  2. #endif
  3.  
  4. /* GNUPLOT - vms.c */
  5.  
  6. /*[
  7.  * Copyright 1986 - 1993, 1998   Thomas Williams, Colin Kelley
  8.  *
  9.  * Permission to use, copy, and distribute this software and its
  10.  * documentation for any purpose with or without fee is hereby granted,
  11.  * provided that the above copyright notice appear in all copies and
  12.  * that both that copyright notice and this permission notice appear
  13.  * in supporting documentation.
  14.  *
  15.  * Permission to modify the software is granted, but not the right to
  16.  * distribute the complete modified source code.  Modifications are to
  17.  * be distributed as patches to the released version.  Permission to
  18.  * distribute binaries produced by compiling modified sources is granted,
  19.  * provided you
  20.  *   1. distribute the corresponding source modifications from the
  21.  *    released version in the form of a patch file along with the binaries,
  22.  *   2. add special version identification to distinguish your version
  23.  *    in addition to the base release version number,
  24.  *   3. provide your name and address as the primary contact for the
  25.  *    support of your modified version, and
  26.  *   4. retain our contact information in regard to use of the base
  27.  *    software.
  28.  * Permission to distribute the released version of the source code along
  29.  * with corresponding source modifications in the form of a patch file is
  30.  * granted with same provisions 2 through 4 for binary distributions.
  31.  *
  32.  * This software is provided "as is" without express or implied warranty
  33.  * to the extent permitted by applicable law.
  34. ]*/
  35.  
  36. /* drop in popen() / pclose() for VMS
  37.  * (originally written by drd for port of perl to vms)
  38.  */
  39.  
  40. #include "plot.h"     /* for the prototypes */
  41. #include "stdfn.h"
  42.  
  43. static int something_in_this_file;
  44.  
  45. #ifdef PIPES
  46.  
  47. /* (to aid porting) - how are errors dealt with */
  48.  
  49. #define ERROR(msg) { fprintf(stderr, "%s\nFile %s line %d\n", msg, __FILE__, __LINE__); }
  50. #define FATAL(msg) { fprintf(stderr, "%s\nFile %s line %d\n", msg, __FILE__, __LINE__); exit(EXIT_FAILURE); }
  51.  
  52.  
  53. #include <dvidef.h>
  54. #include <syidef.h>
  55. #include <jpidef.h>
  56. #include <ssdef.h>
  57. #include <descrip.h>
  58.  
  59. #ifdef __DECC             /* DECC does not automatically search */
  60. #include <lib$routines.h>
  61. #include <starlet.h>      /* for the sys$... routines */
  62. #endif  /* __DECC */
  63.  
  64. #ifndef EXIT_FAILURE                  /* not in older VAXC <stdlib.h> */
  65. #define EXIT_FAILURE 0x10000002       /* (STS$K_ERROR | STS$M_INHIB_MSG */
  66. #endif
  67.  
  68. #define _cksts(call) \
  69.   if (!(sts=(call))&1) FATAL("Internal error") else {}
  70.  
  71. static void
  72. create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
  73. {
  74.     static unsigned long int mbxbufsiz;
  75.         long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
  76.     unsigned long sts;  /* for _cksts */
  77.   
  78.   if (!mbxbufsiz) {
  79.     /*
  80.      * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
  81.      * preprocessor consant BUFSIZ from stdio.h as the size of the
  82.      * 'pipe' mailbox.
  83.      */
  84.  
  85.     _cksts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
  86.     if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ; 
  87.   }
  88.   _cksts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
  89.  
  90.   _cksts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
  91.   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
  92.  
  93. }  /* end of create_mbx() */
  94.  
  95. struct pipe_details
  96. {
  97.     struct pipe_details *next;
  98.     FILE *fp;
  99.     int pid;
  100.     unsigned long int completion;
  101. };
  102.  
  103. static struct pipe_details *open_pipes = NULL;
  104. static $DESCRIPTOR(nl_desc, "NL:");
  105. static int waitpid_asleep = 0;
  106.  
  107. static void
  108. popen_completion_ast(unsigned long int unused)
  109. {
  110.   if (waitpid_asleep) {
  111.     waitpid_asleep = 0;
  112.     sys$wake(0,0);
  113.   }
  114. }
  115.  
  116. FILE *
  117. popen(char *cmd, char *mode)
  118. {
  119.     static char mbxname[64];
  120.     unsigned short int chan;
  121.     unsigned long int flags=1;  /* nowait - gnu c doesn't allow &1 */
  122.     struct pipe_details *info;
  123.     struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
  124.                                       DSC$K_CLASS_S, mbxname},
  125.                             cmddsc = {0, DSC$K_DTYPE_T,
  126.                                       DSC$K_CLASS_S, 0};
  127.     unsigned long sts;                            
  128.  
  129.     if (!(info=malloc(sizeof(struct pipe_details))))
  130.     {
  131.         ERROR("Cannot malloc space");
  132.         return NULL;
  133.     }
  134.  
  135.     info->completion=0;  /* I assume this will remain 0 until terminates */
  136.         
  137.     /* create mailbox */
  138.     create_mbx(&chan,&namdsc);
  139.  
  140.     /* open a FILE* onto it */
  141.     info->fp=fopen(mbxname, mode);
  142.  
  143.     /* give up other channel onto it */
  144.     _cksts(sys$dassgn(chan));
  145.  
  146.     if (!info->fp)
  147.         return NULL;
  148.         
  149.     cmddsc.dsc$w_length=strlen(cmd);
  150.     cmddsc.dsc$a_pointer=cmd;
  151.  
  152.     if (strcmp(mode,"r")==0) {
  153.       _cksts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
  154.                      0  /* name */, &info->pid, &info->completion,
  155.                      0, popen_completion_ast,0,0,0,0));
  156.     }
  157.     else {
  158.       _cksts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
  159.                      0  /* name */, &info->pid, &info->completion));
  160.     }
  161.  
  162.     info->next=open_pipes;  /* prepend to list */
  163.     open_pipes=info;
  164.         
  165.     return info->fp;
  166. }
  167.  
  168. int pclose(FILE *fp)
  169. {
  170.     struct pipe_details *info, *last = NULL;
  171.     unsigned long int abort = SS$_TIMEOUT, retsts;
  172.     unsigned long sts;
  173.     
  174.     for (info = open_pipes; info != NULL; last = info, info = info->next)
  175.         if (info->fp == fp) break;
  176.  
  177.     if (info == NULL)
  178.       /* get here => no such pipe open */
  179.       FATAL("pclose() - no such pipe open ???");
  180.  
  181.     if (!info->completion) { /* Tap them gently on the shoulder . . .*/
  182.       _cksts(sys$forcex(&info->pid,0,&abort));
  183.       sleep(1);
  184.     }
  185.     if (!info->completion)  /* We tried to be nice . . . */
  186.       _cksts(sys$delprc(&info->pid));
  187.     
  188.     fclose(info->fp);
  189.     /* remove from list of open pipes */
  190.     if (last) last->next = info->next;
  191.     else open_pipes = info->next;
  192.     retsts = info->completion;
  193.     free(info);
  194.  
  195.     return retsts;
  196. }  /* end of pclose() */
  197.  
  198.  
  199. /* sort-of waitpid; use only with popen() */
  200. /*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/
  201. unsigned long int
  202. waitpid(unsigned long int pid, int *statusp, int flags)
  203. {
  204.     struct pipe_details *info;
  205.     unsigned long int abort = SS$_TIMEOUT;
  206.     unsigned long sts;
  207.     
  208.     for (info = open_pipes; info != NULL; info = info->next)
  209.         if (info->pid == pid) break;
  210.  
  211.     if (info != NULL) {  /* we know about this child */
  212.       while (!info->completion) {
  213.         waitpid_asleep = 1;
  214.         sys$hiber();
  215.       }
  216.  
  217.       *statusp = info->completion;
  218.       return pid;
  219.     }
  220.     else {  /* we haven't heard of this child */
  221.       $DESCRIPTOR(intdsc,"0 00:00:01");
  222.       unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
  223.       unsigned long int interval[2];
  224.  
  225.       _cksts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
  226.       _cksts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
  227.       if (ownerpid != mypid)
  228.         FATAL("pid not a child");
  229.  
  230.       _cksts(sys$bintim(&intdsc,interval));
  231.       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
  232.         _cksts(sys$schdwk(0,0,interval,0));
  233.         _cksts(sys$hiber());
  234.       }
  235.       _cksts(sts);
  236.  
  237.       /* There's no easy way to find the termination status a child we're
  238.        * not aware of beforehand.  If we're really interested in the future,
  239.        * we can go looking for a termination mailbox, or chase after the
  240.        * accounting record for the process.
  241.        */
  242.       *statusp = 0;
  243.       return pid;
  244.     }
  245.                     
  246. }  /* end of waitpid() */
  247.  
  248. #endif /* PIPES */
  249.  
  250.  
  251. /* vax c doesn't come with strftime - watch out for redefn of RCSid */
  252. #ifdef VAXCRTL
  253. # define RCSid RCSid2
  254. # include "strftime.c"
  255. #endif
  256.